; ORIGINAL: 3dt2.1/examples/schemers/viewer.scm
;;
;; viewer.scm
;;
;; A multi-purpose view control program, used in Chapter 1 of the "Getting
;; Started" book.
;;
;; Edward C. Martin, Schemers Inc.
;; 20 December 1993
;; 08 November 1994, removed all mention of the void object, to ensure
;; compatibility with Elk2.2
;;
(provide 'viewer)

;; Clears the slate.
;;
(part:clear)
(for-each view:delete (env:views))

;;
;; Loads default rendering and coloring procedures.
;;
(require 'rdrpaint "rdrpaint.scm")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                          SET UP PROCEDURES                            ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; view:pair  :  returns a dotted pair whose  car  is the view used in this
;; application and whose  cdr  is a tag identifying which window it is.
;;
(define view:pair
  (let ((V (view:dl 1 1 300 300)))
    (begin
      (view:set-title "View Window" V)
      (cons V "blank"))))

;; establishes YELLOW as the highlight color, and introduces a name --
;; highlight-color-rgb -- for the RGB version of YELLOW.
(env:set-highlight-color YELLOW)
(define highlight-color-rgb (color:int->rgb YELLOW))

;; original-dims  :  records initial view window aspect ratio.
;;
(define original-dims
  (list (view:width (car view:pair))
        (view:height (car view:pair))))

;; render-list  :  a global variable for the list of entities to be rendered.
;;
(define render-list '())

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                       USEFUL UTILITY PROCEDURES                       ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; (filter test? s)  :  retains only those elements of s that PASS test? --
;; or equivalently purges from s all elements that FAIL test?
;; [defined in  letrec  form for efficiency reasons]
;;
(define filter
  (lambda (test? s)
    (letrec ((loop
               (lambda (tail)
                 (if (null? tail)
                     '()
                     (let ((next (car tail)))
                       (if (test? next)
                           (cons next (loop (cdr tail)))
                           (loop (cdr tail))))))))
      (loop s))))

;; (all-but dlist elist)  :  returns all the members of  elist  except for
;; those that belong to  dlist.
;;
(define all-but
  (lambda (dlist elist)
    (filter (lambda (x) (not (member x dlist))) elist)))

;; (D1 num)  :  rounds  num  to one decimal place.
;;
(define D1
  (lambda (num)
    (/ (round (* 10 num)) 10)))

;; (gvec->pos gvec)  :  returns the position whose position vector is  gvec.
;;
(define gvec->pos
  (lambda (gvec)
    (position:offset (position 0 0 0) gvec)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                 PROCEDURES THAT CREATE DISPLAY OBJECTS                ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; (make-axes)  :  returns a figure representing the positive directions of
;; the axes of a right, regular 3D Cartesian coordinate system.
;;
(define make-axes
  (lambda ()
    (begin
      (roll:mark-start)
      (let ((old-auto (env:auto-display)))
        (env:set-auto-display OFF)
        (let ((axes (solid:unite
                      (solid:cylinder
                        (position 0 0 0) (position 45 0 0) 0.5)
                      (solid:cylinder
                        (position 0 0 0) (position 0 45 0) 0.5)
                      (solid:cylinder
                        (position 0 0 0) (position 0 0 45) 0.5)
                      (solid:cone
                        (position 45 0 0) (position 50 0 0) 1.5 0)
                      (solid:cone
                        (position 0 45 0) (position 0 50 0) 1.5 0)
                      (solid:cone
                        (position 0 0 45) (position 0 0 50) 1.5 0)
                      (solid:sphere (position 0 0 0) 0.5))))
          (entity:facet axes)
          (entity:paint axes MAGENTA)
          (roll:mark-end)
          (env:set-auto-display old-auto)
          axes)))))

;; axes  :  returns a set of coordinate axes as an entity.
;;
(define axes (make-axes))

;; (make-object ht)  :  creates an object of the type that is displayed in
;; the View Changer window.
;;
(define make-object
  (lambda (ht)
    (let ((semi-ht (/ ht 2))
          (thick (* 0.075 ht))
          (semi-width (* 0.3 ht))
          (semi-depth (* 0.2 ht)))
      (let ((old-auto (env:auto-display)))
        (env:set-auto-display OFF)
        (let ((B1 (solid:block
                    (position (- semi-depth) (- semi-width) (- semi-ht))
                    (position semi-depth semi-width semi-ht)))
              (C1 (solid:cylinder
                    (position (- semi-ht) 0 0)
                    (position semi-ht 0 0)
                    semi-width))
              (B2 (solid:block
                    (position (- thick semi-depth)
                              (- thick semi-width)
                              (- semi-ht))
                    (position (- semi-depth thick)
                              (- semi-width thick)
                              semi-ht)))
              (C2 (solid:cylinder
                    (position (- semi-ht) 0 0)
                    (position semi-ht 0 0)
                    (- semi-width thick)))
              (C3 (solid:cylinder
                    (position 0 (- semi-ht) (- semi-ht))
                    (position 0 semi-ht semi-ht)
                    (- semi-depth thick))))
          (begin
            (roll:mark-start)
            (let ((object
                    (solid:subtract
                      (solid:unite B1 C1)
                      C2 B2 C3)))
              (begin
                (entity:facet object)
                (entity:paint object (env:default-color))
                (roll:mark-end)
                (env:set-auto-display old-auto)
                object))))))))

;; thing  :  returns the view object for View Changer window.
;;
(define thing (make-object 60))

;; (make-ray dir)  :  returns a figure representing a 50-unit long ray
;; starting at the origin and going in the same direction as  gvec.
;;
(define make-ray
  (lambda (gvec)
    (begin
      (roll:mark-start)
      (let ((old-def-clr (env:default-color))
            (old-auto (env:auto-display))
            (unit-gvec (gvector:unitize gvec)))
        (env:set-auto-display OFF)
        (let ((rod-endpoint (gvec->pos (gvector:scale unit-gvec 45)))
              (pointed-end (gvec->pos (gvector:scale unit-gvec 50))))
          (let ((ray (solid:unite
                       (solid:cylinder
                         (position 0 0 0) rod-endpoint 0.5)
                       (solid:cone
                         rod-endpoint pointed-end 1.5 0))))
            (begin
              (entity:paint ray (env:highlight-color))
              (roll:mark-end)
              (env:set-auto-display old-auto)
              ray)))))))

;; (reject-name str) : displays a message indicating that the name  str
;; is already in use.
;;
(define reject-name
  (lambda (str)
    (format #t "The name ~a is already in use.\n" str)
    (display "Please choose a different name.\n")))

;; (block str pos1 pos2)  :  creates and renders a solid block determined
;; by  pos1  and pos2,  and names it  str.
;;
(define block
  (lambda (str pos1 pos2)
    (if (find-entity "name" str)
        (reject-name str)
        (let ((diag-gvec (gvector:from-to pos1 pos2)))
          (if (zero? (* (gvector:dot diag-gvec (gvector 1 0 0))
                        (gvector:dot diag-gvec (gvector 0 1 0))
                        (gvector:dot diag-gvec (gvector 0 0 1))))
              (begin
                (display "A block is not allowed to have zero thickness.\n")
                (display "The two positions you specify must NOT agree\n")
                (display "in any component. Please try again.\n"))
              (let ((old-auto (env:auto-display)))
                (env:set-auto-display OFF)
                (let ((B (solid:block pos1 pos2)))
                  (begin
                    (attrib:add B "name" str)
                    (entity:paint B (env:default-color))
                    (set! render-list (cons B render-list))
                    (env:set-auto-display old-auto)
                    (shade)
                    (format #t "Block ~a\n" str)
                    ))))))))

;; (cylinder str pos1 pos2 rad)  :  creates and renders a right cylinder
;; with circular faces of radius  rad  centered at  pos1  and  pos2,  and
;; names it  str.
;;
(define cylinder
  (lambda (str pos1 pos2 rad)
    (cond
      ((find-entity "name" str)
       (reject-name str))
      ((equal? pos1 pos2)
       (begin
         (display "A cylinder is not allowed to have zero height.\n")
         (display "The two positions you specify must not be equal.\n")
         (display "Please try again.\n")))
      ((<= rad 0)
       (begin
         (display "A cylinder must have a positive radius.\n")
         (display "Please try again.\n")))
      (else (let ((old-auto (env:auto-display)))
              (env:set-auto-display OFF)
              (let ((C (solid:cylinder pos1 pos2 rad)))
                (begin
                  (attrib:add C "name" str)
                  (entity:paint C (env:default-color))
                  (set! render-list (cons C render-list))
                  (env:set-auto-display old-auto)
                  (shade)
                  (format #t "Cylinder ~a\n" str)
                  )))))))

;; (cone str pos1 pos2 rad1 rad2)  :  creates and renders a frustum of a
;; cone with base radius  rad1  centered at  pos1  and top radius  rad2
;; centered at  pos2,  and names it  str.
(define cone
  (lambda (str pos1 pos2 rad1 rad2)
    (cond
      ((find-entity "name" str)
       (reject-name str))
      ((equal? pos1 pos2)
       (begin
         (display "A cone is not allowed to have zero height.\n")
         (display "The two positions you specify must not be equal.\n")
         (display "Please try again.\n")))
      ((or (< rad1 0) (< rad2 0))
       (begin
         (display "A negative radius is not allowed.\n")
         (display "Please try again.\n")))
      ((zero? (+ rad1 rad2))
       (begin
         (display "You're not allowed to have both radii zero.\n")
         (display "Please try again.\n")))
      (else (let ((old-auto (env:auto-display)))
              (env:set-auto-display OFF)
              (let ((C (solid:cone pos1 pos2 rad1 rad2)))
                (begin
                  (attrib:add C "name" str)
                  (entity:paint C (env:default-color))
                  (set! render-list (cons C render-list))
                  (env:set-auto-display old-auto)
                  (shade)
                  (format #t "Cone ~a\n" str)
                  )))))))

;; (sphere str pos rad)  :  creates and renders a sphere with center  pos
;; and radius  rad,  naming it  str.
;;
(define sphere
  (lambda (str pos rad)
    (cond
      ((find-entity "name" str)
       (reject-name str))
      ((<= rad 0)
       (begin
         (display "A sphere must have a positive radius.\n")
         (display "Please try again.\n")))
      (else (let ((old-auto (env:auto-display)))
              (env:set-auto-display OFF)
              (let ((S (solid:sphere pos rad)))
                (begin
                  (attrib:add S "name" str)
                  (entity:paint S (env:default-color))
                  (set! render-list (cons S render-list))
                  (env:set-auto-display old-auto)
                  (shade)
                  (format #t "Sphere ~a\n" str)
                  )))))))

;; (no-such-object str) : displays a message indicating that there is no
;; object with the given name.
;;
(define no-such-object
  (lambda (str)
    (format #t "There is no object named ~a.\n" str)
    ))

;; (unite str1 str2 ... new-str)  :  unites user-defined objects named by
;; str1,  str2  and so on, to form a new object, named  new-str,  at the
;; same time terminating the independent existence of the original objects.
;;
(define unite
  (lambda args
    (letrec ((separate
               (lambda (s1 s2)
                 (if (null? (cdr s1))
                     (cons (reverse s2) s1)
                     (separate (cdr s1) (cons (car s1) s2))))))
      (let ((input (separate args '())))
        (let ((strs (car input))
              (new-str (cadr input)))
          (if (find-entity "name" new-str)
              (reject-name new-str)
              (let ((objs (map (lambda (x) (find-entity "name" x)) strs)))
                (letrec ((check-non-existence
                           (lambda (things names)
                             (cond
                               ((null? things) #f)
                               ((not (car things)) (car names))
                               (else (check-non-existence
                                       (cdr things) (cdr names)))))))
                  (let ((chk (check-non-existence objs strs)))
                    (if chk
                        (no-such-object chk)
                        (let ((old-auto (env:auto-display)))
                          (env:set-auto-display OFF)
                          (let ((new-obj (apply solid:unite objs)))
                            (begin
                              (attrib:replace new-obj "name" new-str)
                              (entity:paint new-obj (env:default-color))
                              (set! render-list
                                    (cons new-obj
                                          (all-but objs render-list)))
                              (env:set-auto-display old-auto)
                              (shade)
                              (format #t "New object ~a\n" new-str)
                              )))))))))))))

;; (intersect str1 str2 str3)  :  intersects user-defined objects named by
;; str1  and  str2,  creating a new object named  str3,  at the same time
;; terminating the independent existence of the original two objects.
;;
(define intersect
  (lambda (str1 str2 str3)
    (if (find-entity "name" str3)
        (reject-name str3)
        (let ((obj1 (find-entity "name" str1))
              (obj2 (find-entity "name" str2)))
          (cond
            ((not obj1)
             (no-such-object str1))
            ((not obj2)
             (no-such-object str2))
            (else (let ((old-auto (env:auto-display)))
                    (env:set-auto-display OFF)
                    (let ((new-obj (solid:intersect obj1 obj2)))
                      (begin
                        (attrib:replace new-obj "name" str3)
                        (entity:paint new-obj (env:default-color))
                        (set! render-list
                              (cons new-obj
                                    (all-but (list obj1 obj2) render-list)))
                        (env:set-auto-display old-auto)
                        (shade)
                        (format #t "New object ~a\n" str3)
                        )))))))))

;; (subtract str1 str2 str3)  :  subtracts the user-defined object named by
;; str2  from the user-defined object named  str1,  creating a new object
;; named  str3, and at the same time terminating the independent existence
;; of the original objects.
;;
(define subtract
  (lambda (str1 str2 str3)
    (if (find-entity "name" str3)
        (reject-name str3)
        (let ((obj1 (find-entity "name" str1))
              (obj2 (find-entity "name" str2)))
          (cond
            ((not obj1)
             (no-such-object str1))
            ((not obj2)
             (no-such-object str2))
            (else (let ((old-auto (env:auto-display)))
                    (env:set-auto-display OFF)
                    (let ((new-obj (solid:subtract obj1 obj2)))
                      (begin
                        (attrib:replace new-obj "name" str3)
                        (entity:paint new-obj (env:default-color))
                        (set! render-list
                              (cons new-obj
                                    (all-but (list obj1 obj2) render-list)))
                        (env:set-auto-display old-auto)
                        (shade)
                        (format #t "New object ~a\n" str3)
                        )))))))))

;; (hide str)  :  hides the user-defined object named by  str  without
;; destroying it.
;;
(define hide
  (lambda (str)
    (let ((obj (find-entity "name" str)))
      (cond
        ((not obj)
         (no-such-object str))
        ((member obj render-list)
         (begin
           (set! render-list (all-but (list obj) render-list))
           (shade)
           'done))
        (else (format #t "Object ~a is already hidden.\n" str))))))

;; (reveal str)  :  reveals the user-defined object named by  str.
;;
(define reveal
  (lambda (str)
    (let ((obj (find-entity "name" str)))
      (cond
        ((not obj)
         (no-such-object str))
        ((member obj render-list)
         (format #t "Object ~a is already revealed.\n" str))
        (else (begin
                (set! render-list (cons obj render-list))
                (shade)
                'done))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                       SCREEN DISPLAY PROCEDURES                       ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; (label-axes)  :  displays temporary labels on the axes -- appropriate when
;; the view gvector is close to #[gvector 1 -2 1] and the target is the
;; origin.
;;
(define label-axes
  (lambda ()
    (begin
      (view:set-fg-color GREEN (car view:pair))
      (view:draw-text (position 50 0 0) "x" (car view:pair))
      (view:draw-text (position 0 53 0) "y" (car view:pair))
      (view:draw-text (position -5 0 52) "z" (car view:pair))
      'done)))

;; (refresh)  :  refreshes the Position Locator view and, if the
;; view-gvector is close to #[gvector 1 -2 1], relabels axes.
;;
(define refresh
  (lambda ()
    (begin
      (render render-list (car view:pair))
      (if (< (gvector:length
               (gvector:cross (gvector:from-to
                                (view:target (car view:pair))
                                (view:eye (car view:pair)))
                              (gvector 1 -2 1)))
             0.001)
          (label-axes))
      'done)))

;; (shade)  :  renders everything in the render-list and highlights all
;; located points.
(define shade
  (lambda ()
    (begin
      (if (null? render-list)
          (view:refresh (car view:pair))
          (render render-list (car view:pair)))
      (entity:set-highlight (points (part:entities)) ON))))

;; (shade/refresh)  :  redisplays the current situation based upon which
;; of the application's windows we are in.
;;
(define shade/refresh
  (lambda ()
    (if (which-window "locator")
        (begin
          (refresh)
          (entity:display
            (all-but (append (list axes thing) paint-etc) (part:entities))))
        (shade))))

;; (show pos)  or  (show gvec pos) :
;; with one argument (which must be a position), displays the position
;; together with its construction box and canonical path from the origin;
;; with two arguments (the first of which must be a gvector and the second
;; of which must be a position), displays the result of adding the gvector
;; to the position together with the construction box between the two
;; points, the canonical path from the first position to the second, and the
;; space diagonal representing the gvector.
;;
(define show
  (lambda args
    (if (not (which-window "locator"))
        (begin
          (display "Before you can  show  anything, you must\n")
          (display "be working in the Position Locator Window.\n")
          (display "Type  (locator)  and try again.\n"))
        (let ((arg1 (car args)))
          (begin
            (entity:delete (pewb (part:entities)))
            (refresh)
            (if (position? arg1)
                (pshow (position 0 0 0) arg1)
                (if (or (null? (cdr args))
                        (not (position? (cadr args))))
                    (begin
                      (display "Instructions should be in one of these ")
                      (display "forms:\n")
                      (display "   (show (gvector # # #) ")
                      (display "(position # # #))\n")
                      (display "   (show (position # # #))\n")
                      (display "Please try again.\n"))
                    (let ((arg2 (cadr args)))
                      (let ((p2 (position:offset arg2 arg1)))
                        (begin
                          (pshow arg2 p2)
                          (colored-line arg2 p2 RED)
                          'done))))))))))

;; (pshow pos1 pos2)  :  generates wire frame box determined by pos1 and
;; pos2, and highlights the canonical path from pos1 to pos2.
;;
(define pshow
  (lambda (pos1 pos2)
    (let* ((gvec (gvector:from-to pos1 pos2))
           (x (gvector:x gvec))
           (y (gvector:y gvec))
           (z (gvector:z gvec)))
      (wire-frame-box pos1 x y z)
      (colored-point pos2 (env:highlight-color))
      'done)))

;; (smart-edge:linear pos1 pos2)  :  returns the linear-edge between  pos1
;; and  pos2  provided  pos1  and  pos2  are distinct, but the boolean #f
;; otherwise.
(define smart-edge:linear
  (lambda (pos1 pos2)
    (if (equal? pos1 pos2)
        #f
        (edge:linear pos1 pos2))))

;; (wire-frame-box pos1 x y z)  :  generates the wire frame box determined by
;; pos1 and the position offset from pos1 by #[gvector x y z].
;;
(define wire-frame-box
  (lambda (pos1 x y z)
    (let* ((upos2 (position:offset pos1 (gvector x 0 0)))
           (upos3 (position:offset upos2 (gvector 0 y 0)))
           (upos4 (position:offset pos1 (gvector 0 y 0)))
           (dpos1 (position:offset pos1 (gvector 0 0 z)))
           (dpos2 (position:offset upos2 (gvector 0 0 z)))
           (dpos3 (position:offset upos3 (gvector 0 0 z)))
           (dpos4 (position:offset upos4 (gvector 0 0 z))))
      (begin
        (smart-edge:linear upos3 upos4)
        (smart-edge:linear upos4 pos1)
        (smart-edge:linear pos1 dpos1)
        (smart-edge:linear upos2 dpos2)
        (smart-edge:linear upos4 dpos4)
        (smart-edge:linear dpos1 dpos2)
        (smart-edge:linear dpos2 dpos3)
        (smart-edge:linear dpos3 dpos4)
        (smart-edge:linear dpos4 dpos1)
        (colored-line pos1 upos2 (env:highlight-color))
        (colored-line upos2 upos3 (env:highlight-color))
        (colored-line upos3 dpos3 (env:highlight-color))
        'done))))

;; (colored-line pos1 pos2 clr)  :  creates line joining pos1 and pos2,
;; displaying it in color clr.
;;
(define colored-line
  (lambda (pos1 pos2 clr)
    (let ((old-def-clr (env:default-color)))
      (env:set-default-color clr)
      (let ((seg (smart-edge:linear pos1 pos2)))
        (begin
          (env:set-default-color old-def-clr)
          seg)))))

;; (colored-point pos clr)  :  creates a point entity at position pos,
;; displaying it in color clr.
;;
(define colored-point
  (lambda (pos clr)
    (let ((old-def-clr (env:default-color)))
      (env:set-default-color clr)
      (let ((pt (point pos)))
        (begin
          (env:set-default-color old-def-clr)
          pt)))))

;; (locate pos)  :  highlights point at position pos, and represents it by a
;; little sphere
;;
(define locate
  (lambda (pos)
    (let ((old-auto-mode (env:auto-display))
          (old-def-clr (env:default-color)))
      (env:set-auto-display OFF)
      (env:set-default-color (env:highlight-color))
      (let ((newpt (point pos))
            (fatpt (solid:sphere pos 1.5)))
        (begin
          (attrib:add fatpt "fatpt" pos)
          (entity:paint fatpt (env:highlight-color))
          (set! render-list (cons fatpt render-list))
          (shade/refresh)
          (entity:display newpt)
          (env:set-auto-display old-auto-mode)
          (env:set-default-color old-def-clr)
          'done)))))

;; (delocate pos)  :  deletes and unhighlights the point at position pos, and
;; deletes the corresponding little sphere point-marker.
;;
(define delocate
  (lambda (pos)
    (let ((fatpt (find-entity "fatpt" pos)))
      (begin
        (if fatpt
            (begin
              (set! render-list (all-but (list fatpt) render-list))
              (entity:delete (list (find-point pos) fatpt))))
        (shade/refresh)
        'done))))

;; (include-axes)  :  displays the axes in the view window.
;;
(define include-axes
  (lambda ()
    (begin
      (if (not (member axes render-list))
          (set! render-list (cons axes render-list)))
      (shade/refresh)
      'done)))

;; (remove-axes)  :  removes the axes from any view window except the
;; Position Locator window.
;;
(define remove-axes
  (lambda ()
    (begin
      (if (which-window "locator")
          (begin
            (display "Sorry. I'm not allowed to remove the\n")
            (display "axes from the Position Locator window.\n"))
          (begin
            (set! render-list (all-but (list axes) render-list))
            (shade/refresh)
            'done)))))

;; (include-ray gvec)  :  highlights the 50-unit ray starting at the origin
;; that goes in the same direction as  gvec.
;;
(define include-ray
  (lambda (gvec)
    (let ((ray (make-ray gvec)))
      (begin
        (attrib:add ray "ray" (position:offset (position 0 0 0) gvec))
        (set! render-list (cons ray render-list))
        (shade/refresh)
        'done))))

;; (remove-ray gvec)  :  deletes and unhighlights the ray starting at the
;; origin and going in the same direction as  gvec.
;;
(define remove-ray
  (lambda (gvec)
    (let ((ray (find-entity "ray" (position:offset (position 0 0 0) gvec))))
      (begin
        (if ray
            (begin
              (set! render-list (all-but (list ray) render-list))
              (entity:delete ray)))
        (shade/refresh)
        'done))))

;; (destroy str)  :  deletes the user-defined solid with name  str.
;;
(define destroy
  (lambda (str)
    (let ((object (find-entity "name" str)))
      (if (not object)
          (no-such-object str)
          (begin
            (set! render-list (all-but (list object) render-list))
            (entity:delete object)
            (shade)
            'done)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                   INFORMATION-GATHERING PROCEDURES                    ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; (which-window str)  :  returns  #t  if and only if the window
;; identification string is  str.
;;
(define which-window
  (lambda (str)
    (string=? str (cdr view:pair))))

;; (points elist)  :  returns a list of all point entities in  elist.
;;
(define points
  (lambda (elist)
    (filter point? elist)))

;; (pewb elist)  :  returns a list of all the points, edges (of whatever
;; type), and wire-bodies in  elist.
;;
(define pewb
  (lambda (elist)
    (filter (lambda (x)
              (or (edge? x) (point? x) (wire-body? x)))
            elist)))

;; (find-point pos)  :  returns the point entity at position  pos.
;;
(define find-point
  (lambda (pos)
    (letrec ((search
               (lambda (elist)
                 (if (null? elist)
                     #f
                     (let ((next (car elist)))
                       (if (and (point? next)
                                (equal? (point:position next) pos))
                           next
                           (search (cdr elist))))))))
      (search (part:entities)))))

;; (get-value attrib ent)  :  if  ent has attribute  attrib,  returns the
;; value of that attribute; otherwise, returns #f.
;;
(define get-value
  (lambda (attrib ent)
    (let ((att (attrib:get ent attrib)))
      (if (null? att)
          #f
          (cdar att)))))

;; (find-entity attrib val)  :  returns the entity whose attribute  attrib
;; has value  val.
;;
(define find-entity
  (lambda (attrib val)
    (letrec ((search
               (lambda (elist)
                 (if (null? elist)
                     #f
                     (let* ((next (car elist))
                            (next-val (get-value attrib next)))
                       (if (and next-val
                                (equal? next-val val))
                           next
                           (search (cdr elist))))))))
      (search (part:entities)))))

;; (?eye)  :  returns the current eye position.
;;
(define ?eye
  (lambda ()
    (begin
      (display "     Eye position:  ")
      (report-position (view:eye (car view:pair))))))

;; (?target)  :  returns the current target.
;;
(define ?target
  (lambda ()
    (begin
      (display "           Target:  ")
      (report-position (view:target (car view:pair))))))

;; (?distance)  :  returns the current view distance.
;;
(define ?distance
  (lambda ()
    (format #t " Viewing distance:  ~a\n"
            (D1 (gvector:length
                  (gvector:from-to
                    (view:target (car view:pair))
                    (view:eye (car view:pair))))))))

;; (?height)  :  returns the current view height.
;;
(define ?height
  (lambda ()
    (format #t "      View height:  ~a\n"
            (D1 (view:height (car view:pair))))))

;;(object-list) : looks for entities with name components and if none are found,
;;returns the statement, "No objects currently exist. \n"  If items are found,
;;refers to object-list-helper to list them correctly.
;;
(define object-list
  (lambda ()
    (letrec ((scan
               (lambda (s)
                 (if (null? s)
                     (format (current-output-port) "No objects currently exist.  \n" )
                     (let ((next (get-value "name" (car s))))
                       (begin
                         (if (not next)
                             (scan (cdr s))
                             (object-list-helper))))))))
      (scan (part:entities)))))

;; (object-list-helper)  :  returns a listing of the names of all existing user-
;; defined objects without always printing "No objects currently exist".
;;
(define object-list-helper
  (lambda ()
    (letrec ((scan
               (lambda (s)
                 (if (null? s)
                     (format (current-output-port) "" )
                     (let ((next (get-value "name" (car s))))
                       (begin
                         (if next
                             (begin
                               (display next) (newline)))
                         (scan (cdr s))))))))
      (scan (part:entities)))))



;;(visible-object-list) : looks for entities with name components and if none are found,
;;returns the statement, "No objects are currently visible. \n"  If items are found,
;;refers to object-list-helper to list them correctly.
;;
(define visible-object-list
  (lambda ()
    (letrec ((scan
               (lambda (s)
                 (if (null? s)
                     (format #t "No objects are currently visible.\n")
                     (let ((next (get-value "name" (car s))))
                       (begin
                         (if (not next)
                             (scan (cdr s))
                             (visible-object-list-helper))))))))
      (scan render-list))))

;; (visible-object-list-helper)  :  returns a listing of the names of all existing visible user-
;; defined objects without always printing "No objects are currently visible".
;;
(define visible-object-list-helper
  (lambda ()
    (letrec ((scan
               (lambda (s)
                 (if (null? s)
                     (format #t "")
                     (let ((next (get-value "name" (car s))))
                       (begin
                         (if next
                             (begin
                               (display next) (newline)))
                         (scan (cdr s))))))))
      (scan render-list))))

;;(invisible-object-list) : looks for entities with name components and if none are found,
;;returns the statement, "No objects are currently invisible. \n"  If items are found,
;;refers to object-list-helper to list them correctly.
;;
(define invisible-object-list
  (lambda ()
    (letrec ((scan
               (lambda (s)
                 (if (null? s)
                     (format (current-output-port) "No objects are currently invisible.\n")
                     (let ((next-name (get-value "name" (car s))))
                       (begin
                         (if next-name
                             (let ((next-obj (find-entity "name" next-name)))
                               (if (member next-obj render-list)
                                   (scan (cdr s))
                                   (invisible-object-list-helper)))
                             (scan (cdr s)))))))))
      (scan (part:entities)))))

  ;; (invisible-object-list-helper)  :  returns a listing of the names of all existing visible user-
  ;; defined objects without always printing "No objects are currently invisible".
  ;;
(define invisible-object-list-helper
  (lambda ()
    (letrec ((scan
               (lambda (s)
                 (if (null? s)
                     (format (current-output-port) "")
                     (let ((next-name (get-value "name" (car s))))
                       (begin
                         (if next-name
                             (let ((next-obj (find-entity "name" next-name)))
                               (if (not (member next-obj render-list))
                                   (begin
                                     (display next-name) (newline)))))
                         (scan (cdr s))))))))
      (scan (part:entities)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;             PROCEDURES THAT CHANGE VIEW PARAMETERS                    ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; (perspective)  :  sets perspective mode.
;;
(define perspective
  (lambda ()
    (view:set-perspective ON (car view:pair))
    (shade/refresh)
    (report)))

;; (orthographic)  :  sets orthographic mode.
;;
(define orthographic
  (lambda ()
    (view:set-perspective OFF (car view:pair))
    (shade/refresh)
    (report)))

;; (change-eye-to pos)  :  moves eye position to  pos.
;;
(define change-eye-to
  (lambda (pos)
    (let ((target (view:target (car view:pair))))
      (cond
        ((equal? pos target)
         (begin
           (display "The eye position must be different from\n")
           (display "the target. Choose a different eye position.\n")))
        ((zero? (gvector:length
                  (gvector:cross
                    (view:up (car view:pair))
                    (gvector:from-to target pos))))
         (begin
           (display "The gvector from the target to the eye\n")
           (display "position must not be a multiple of the\n")
           (display "up-gvector. Choose a different eye position.\n")))
        (else (begin
                (view:set-eye pos (car view:pair))
                (shade/refresh)
                (report)))))))

;; (change-target-to pos)  :  moves the target to  pos.
;;
(define change-target-to
  (lambda (pos)
    (let ((eye (view:eye (car view:pair))))
      (cond
        ((equal? pos eye)
         (begin
           (display "The target must be different from the\n")
           (display "eye position. Choose a different target.\n")))
        ((zero? (gvector:length
                  (gvector:cross
                    (view:up (car view:pair))
                    (gvector:from-to pos eye))))
         (begin
           (display "The gvector from the target to the eye\n")
           (display "position must not be a multiple of the\n")
           (display "up-gvector. Choose a different target.\n")))
        (else (begin
                (view:set-target pos (car view:pair))
                (shade/refresh)
                (report)))))))

;; (zoom-to-distance d)  :  changes the view distance to d, repositioning the
;; eye position accordingly.
;;
(define zoom-to-distance
  (lambda (d)
    (if (<= d 0)
        (begin
          (display "The view distance must be positive.\n")
          (display "Choose a different view distance.\n"))
        (let ((eye (view:eye (car view:pair)))
              (target (view:target (car view:pair))))
          (view:set-eye
            (position:offset
              target
              (gvector:scale
                (gvector:unitize
                  (gvector:from-to target eye))
                d))
            (car view:pair))
          (shade/refresh)
          (report)))))

;; (change-up-to gvec)  :  changes the up-gvector to a unitized version
;; of  gvec.
;;
(define change-up-to
  (lambda (gvec)
    (if (zero? (gvector:length
                 (gvector:cross
                   gvec
                   (gvector:from-to
                     (view:target (car view:pair))
                     (view:eye (car view:pair))))))
        (begin
          (display "The up-gvector must not be a multiple of\n")
          (display "the gvector from the target to the eye\n")
          (display "position. Choose a different up-gvector.\n"))
        (begin
          (view:set-up gvec (car view:pair))
          (shade/refresh)
          (report)))))

;; (change-width-to w)  :  changes the view width to w, and changes the view
;; height so as to preserve the aspect ratio.
;;
(define change-width-to
  (lambda (w)
    (let ((oldw (view:width (car view:pair)))
          (oldh (view:height (car view:pair))))
      (begin
        (view:set-size w (/ (* oldh w) oldw) (car view:pair))
        (shade/refresh)
        (report)))))

;; (change-height-to h)  :  changes the view height to h, and changes the
;; view width so as to preserve the aspect ratio.
;;
(define change-height-to
  (lambda (h)
    (let ((oldw (view:width (car view:pair)))
          (oldh (view:height (car view:pair))))
      (begin
        (view:set-size (/ (* oldw h) oldh) h (car view:pair))
        (shade/refresh)
        (report)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                  VIEW PARAMETER REPORTING PROCEDURES                  ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; (report-position pos)  :  reports a position with its components rounded
;; to one decimal place.
;;
(define report-position
  (lambda (pos)
    (format #t "#[position ~a ~a ~a]\n"
            (number->string (D1 (position:x pos)))
            (number->string (D1 (position:y pos)))
            (number->string (D1 (position:z pos))))))

;; (report-gvector gvec)  :  reports a gvector with its components rounded
;; to one decimal place.
;;
(define report-gvector
  (lambda (gvec)
    (format #t "#[gvector ~a ~a ~a]\n"
            (number->string (D1 (gvector:x gvec)))
            (number->string (D1 (gvector:y gvec)))
            (number->string (D1 (gvector:z gvec))))))

;; (report)  :  reports the current values of the view parameters.
;;
(define report
  (lambda ()
    (let ((eye (view:eye (car view:pair)))
          (target (view:target (car view:pair))))
      (newline)
      (display "     Eye position:  ")
      (report-position eye)
      (display "           Target:  ")
      (report-position target)
      (format #t " Viewing distance:  ~a\n"
              (D1 (gvector:length
                    (gvector:from-to target eye))))
      (display "       Up-gvector:  ")
      (report-gvector (view:up (car view:pair)))
      (format #t "       Projection:  ~a\n"
              (if (view:perspective? (car view:pair))
                  "Perspective"
                  "Orthographic"))
      (format #t "       View width:  ~a\n"
              (D1 (view:width (car view:pair))))
      (format #t "      View height:  ~a\n"
              (D1 (view:height (car view:pair)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                    VIEW WINDOW INITIALIZATION PROCEDURES              ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; initializes the Position Locator window
;;
(define locator
  (lambda ()
    (begin
      (view:set-title "Position Locator" (car view:pair))
      (view:set (position 50 -100 50)
                (position 0 0 0)
                (gvector 0 0 1)
                (car view:pair))
      (view:set-size (car original-dims) (cadr original-dims) (car view:pair))
      (set! render-list (list axes))
      (set-cdr! view:pair "locator")
      (env:set-point-style "o")
      (view:set-perspective OFF (car view:pair))
      (entity:delete (all-but (append (list axes thing) paint-etc)
                              (part:entities)))
      (refresh))))

;; initializes the View Changer window
;;
(define viewer
  (lambda ()
    (begin
      (view:set-title "View Changer" (car view:pair))
      (view:set (position 50 -100 50)
                (position 0 0 0)
                (gvector 0 0 1)
                (car view:pair))
      (view:set-size (car original-dims) (cadr original-dims) (car view:pair))
      (set! render-list (list thing))
      (set-cdr! view:pair "viewer")
      (env:set-point-style "x")
      (view:set-perspective OFF (car view:pair))
      (entity:delete (all-but (append (list axes thing) paint-etc)
                              (part:entities)))
      (shade))))

;; initializes the Building Blocks window
;;
(define blocks
  (lambda ()
    (begin
      (view:set-title "Building Blocks" (car view:pair))
      (view:set (position 50 -100 50)
                (position 0 0 0)
                (gvector 0 0 1)
                (car view:pair))
      (view:set-size (car original-dims) (cadr original-dims) (car view:pair))
      (set! render-list '())
      (set-cdr! view:pair "blocks")
      (env:set-point-style "x")
      (view:set-perspective OFF (car view:pair))
      (entity:delete (all-but (append (list axes thing) paint-etc)
                              (part:entities)))
      (shade))))

;;
;; end of file  viewer.scm
